perm filename DRAWSM.F4[RST,LCS] blob
sn#163324 filedate 1975-06-10 generic text, type T, neo UTF8
00100 SUBROUTINE DRAWIT
00200 COMMON/ED/K,NEXT,NN,NX,NY,J
00300 COMMON /RZ/RSZ,IPLT,RJB,CENTR
00400 COMMON /RC/MCLEF(400),IST(4000)
00500 COMMON/ZN/SCLEF(400,2),DDD
00600 COMMON/LL/LL
00610 COMMON/JJJ/JJJ
00620 DIMENSION ITEM(20)
00700 EQUIVALENCE(MM,SCLEF(1,1)),(W,IST(4000))
00800 DATA RN/15./
00900 CC CALL ACCPOG(1)
01000 C DISPLAYS OLD ITEM WITHOUT FILLER
01100 CC CALL DPYOUT(1)
01200 REL=-1
01300 JC=0
01500 KE=-1
01600 JCL=0
01700 RJ=1
01900 IF(MM.EQ.0)GO TO 20
02000 J=MM
02100 JX=-1
02200 JCL=MM
02300 NX=SCLEF(MM,1)
02400 NY=SCLEF(MM,2)
02500 GO TO 120
02600 CC20 IF(JF.EQ.0)J=1
02900 20 J=1
03000 JZ=J
03200 2 NX=RJB*RSZ
03300 NY=CENTR*RSZ
03500 121 JX=0
03600 120 NZ=-1
03700 JC=1
03800 RL=NX
03900 RM=NY
04000 C L AND M ARE USED AS CONSTANTS WHEN RESETTING CURSOR
04100 44 CALL SETCUR(NX,NY,0)
04200 83 S=0
04300 4 IF(S)GO TO 81
04320 CJ NO MORE LIGHT PEN SELECTION. IF(K.EQ.'E')GO TO 700
04340 IF(K.EQ.'E')GO TO 79
04360 C BYPASS FOR EDITING.
04380 45 FORMAT(' <CR> SETS POINT ',$)
04400 TYPE 45
04500 ACCEPT 144,K,ZK,KK
04600 IF(ZK.NE.'E')GO TO 344
04700 REL=0
04800 C TYPE REL FOR RELATIVE VECTORS, O=ORDINARY
04900 GO TO 4
05000 344 IF(K.NE.'O')GO TO 244
05100 REL=-1
05200 GO TO 4
05300 144 FORMAT(3A1)
05315 244 IF(ZK.NE.'M')GO TO 444
05316 C TYPE SM TO SMOOTH, SMX=ERASE STRAIGHT LINES TEMPORARILY.
05317 MCLEF(1)=J
05318 CALL SMOOTH(KK)
05319 GO TO 4
05320 444 IF(ZK.NE.'X')GO TO 445
05330 MCLEF(2)=MCLEF(2)+200000000
05335 K='X'
05340 GO TO 3
05400 445 REREAD 1,K,ZK,XK
05500 IF(K.LE.' ')GO TO 40
05600 REREAD 11,RJ,RK,XK
05700 JMPR=0
05800 IF(XK.EQ.1)K='J'
05900 C TYPE 3RD NUM=1 FOR JUMPS
05910 IF(XK.EQ.2)K='F'
05920 C IF 3RD NUM=2 -- BEGIN FILL SECTION
06000 41 QJ=RJ
06100 QK=RK
06200 IF(REL)GO TO 141
06300 241 X=X+QJ*RSZ
06400 Y=Y+QK*RSZ
06500 NX=X
06600 NY=Y
06700 GO TO 48
06800 141 NX=GTPT(RJ,RJB)
06900 NY=GTPT(RK,CENTR)
07000 X=NX
07100 Y=NY
07200 GO TO 481
07300 40 KK=ZK
07400 C B=BACKUP, J=JUMP, CR=SET POINT, X=EXIT, LRUD-N
07500 C F=FILL IT, H=GO TO HOME-NUM, N=GO TO NEXT(AFTER AN 'H')
07600 C Z=ZERO IN ON NEARBY POINT, P=GO TO PREVIOUS, C=CLOSE THE AREA
07700 C D=EXTEND DRAWING, F=START FILLER OUTLINE, SM=SMOOTH IT
07800 C TYPE 'FX' TO FILL ORIGINAL OUTLINE AND EXIT.
07810 C L,R,U,D + NUM MOVES LAST POINT ENTERED.
07900 IF(ZK.NE.0)NZ=-1
08000 C WILL STAY IN "Z" MODE UNLESS NUMBER APPEARS.
08100 JMPR=0
08200 JCX=2
08300 C JCX IS FOR "ZEROING-IN" SECTION AND EDIT SECTION
08400 C FOR SHIFTS OF "JUMPS"
08500 IF(K.EQ.'B')GO TO 22
08600 CC IF(K.EQ.'P')GO TO 56
08700 IF(K.EQ.'C')GO TO 51
08900 IF(K.EQ.'X')GO TO 3
09000 IF(K.EQ.' ')GO TO 47
09050 IF(K.EQ.'J')GO TO 47
09075 IF(K.EQ.'Z')GO TO 47
09100 IF(K.EQ.'S')GO TO 79
09110 IF(K.EQ.'F')GO TO 47
09200 CC555 IF(K.NE.'N')GO TO 7
09205 C****** NO MORE 'N' OR 'P' ******
09210 IF(K.NE.'H')GO TO 7
09300 CC55 KK=NEXT
09400 CC GO TO 52
09500 CC56 KK=NEXT-2
09600 52 IF(KK.LE.1)KK=2
09700 X=SCLEF(KK,1)
09800 Y=SCLEF(KK,2)
09900 NEXT=KK+1
10000 IF(KE)GO TO 48
10100 RX=X
10200 RY=Y
10202 58 IF(NEXT.GT.J+1)GO TO 44
10205 NN=JA-1
10210 CALL ITYP
10300 CALL EDTYP(K,X,Y,JJJ)
10600 C TYPE "A" OR ":" TO ALTER
10800 C TYPE "G"=GROUP CHANGE) TO MAKE RELATIVE CHANGE STICK
10850 C , THEN <CR>S. ANY OTHER LETTER TO ESCAPE
10900 IF(K.NE.'J')GO TO 573
10910 C J=JUMP TO NEXT 'JUMP'
10920 DO 574 K=NEXT,J
10930 574 IF(MCLEF(K).GE.100000000)GO TO 575
10940 575 X=K-NEXT+1
10950 GO TO 82
10960 573 IF(K.LT.'-')GO TO 1573
10970 C NEXT FOR NUMBERS ONLY -- FOR STEP AHEAD AND BACK
10980 2573 REREAD 11,X
10990 GO TO 82
11000 1573 IF(K.NE.'B')GO TO 570
11020 X=-X
11040 GO TO 82
11100 570 IF(K.NE.' ')GO TO 1570
11200 IF(S)GO TO 81
11300 1570 IF(K.EQ.'S')GO TO 82
11400 C S=STEP AHEAD(N) (-N OR B GOES BACK)
11500 IF(K.EQ.'X')GO TO 3
11510 IF(K.NE.'M'.AND.K.NE.'R')GO TO 572
11511 C M OR R ALONE WILL MOVE LAST SET OF POINTS MOVED. BUT BE CAREFUL!
11512 LL=0
11513 IF(X+Y.EQ.0)GO TO 580
11515 IF(X.OR.Y.EQ.0)GO TO 577
11517 C "M -N1, N2, N3" MOVES WHOLE BLOCKS (OR "M N1 0")
11518 C OR USE 'R' FOR 'M' TO ROTATE GROUP OF POINTS
11519 C TO SET ITEM # N2≠0, SETS ITEM # TO N3 IF N3≠0.
11524 NY=Y-X+2
11526 NX=X+1
11530 576 MX=NX
11532 MY=NY
11535 CC IF(K.EQ.'R')MY=-MY
11537 CC580 NY=MY
11540 580 CALL SHIFT(MCLEF(MX),MY,K)
11550 C TO MOVE SEGS MX THROUGH MY.
11555 CALL CLRPOG(1)
11560 CALL POG1
11570 CALL RDRAW(2,MCLEF(1),MCLEF)
11580 CALL DPYOUT(1)
11590 GO TO 58
11600
11610 577 NX=ABS(X)
11620 IF(Y.NE.0)GO TO 578
11630 CALL UNPACK(NX,NX,NY,ITEM)
11640 GO TO 576
11650 578 NY=ABS(Y)
11660 IF(JJJ.NE.0)GO TO 579
11670 IK=IK+1
11680 TYPE 46,IK
11690 JJJ=IK
11700 IF(JJJ.GT.10)GO TO 58
11705 CC579 JB=NX
11707 579 LL=0
11715 NY=NY-NX+2
11716 NX=NX+1
11717 JB=NX
11718 CALL REPACK(JJJ,JB,NY,ITEM)
11720 GO TO 576
11730
11900 572 MCLEF(1)=J
11950 IF(K.EQ.'F')GO TO 470
12000 C TAKE OUT OTHER 'F'S IN DREDIT*****
12050 571 CALL DREDIT
12100 59 X=RX
12200 Y=RY
12300 KE=-1
12320 NX=0
12340 NY=0
12400 GO TO 170
12500 C THIS WRECKS "CLOSE"
12510 470 MCLEF(NEXT-1)=MCLEF(NEXT-1)+200000000
12520 K='X'
12530 GO TO 34
12600 47 IF(REL.EQ.0)GO TO 22
12700 C IF IN "REL" MODE TYPE "O" BEFORE USING LTPEN
12800 CALL RDCUR(NX,NY)
12900 X=NX
13000 Y=NY
13100 IF((K.NE.'Z'.AND.NZ).OR.K.EQ.'J'.OR.K.EQ.'F')GO TO 48
13200 NZ=0
13300 DO 54 K=JCX,JCL
13400 IF(ABS(SCLEF(K,1)-X).GT.RN.OR.ABS(SCLEF(K,2)-Y).GT.RN)
13500 1 GO TO 54
13600 KK=K
13700 GO TO 52
13800 54 CONTINUE
13900 IF(KE)GO TO 48
13950 C KE=-1 = DRAW MODE (NOT EDIT)
14000 TYPE 154
14100 GO TO 4
14200 154 FORMAT(' NO POINT FOUND ')
14400 C ABOVE FOR INITIAL MOVEMENT OF CURSOR
14500 51 X=RX
14600 Y=RY
14700 48 RJ=STPT(X,RJB)
14800 RK=STPT(Y,CENTR)
14900 481 SK=RK
15000 J=J+1
15100 551 SJ=RJ
15200 C DO I NEED RJ,RK ANYWHERE?? YES - AT REPACK
15300 451 LL=0
15400 IF(K.EQ.'J')LL=100000000
15500 C J=JUMP
15510 IF(K.NE.'F')GO TO 452
15515 K='J'
15555 253 LL=200000000
15600 452 IJ=RJ
15700 IK=RK
15900 JCL=J
16000 CALL REPACK(J,IJ,IK,MCLEF)
16100 IF(MCLEF(J).NE.MCLEF(J-1).OR.J.EQ.2)GO TO 60
16200 61 J=J-1
16300 GO TO 4
16400 60 SCLEF(J,1)=X
16500 SCLEF(J,2)=Y
16900 50 N=IST(2)
17000 X=GTPT(SJ,RJB)
17100 Y=GTPT(SK,CENTR)
17200 NX=X
17300 NY=Y
17400 IF(K.EQ.'B')GO TO 5
17500 IF(K.EQ.'J'.OR.JMPR.OR.JX.EQ.0)GO TO 6
17600 CALL AVECT(NX,NY)
17700 GO TO 5
17800 6 CALL AIVECT(NX,NY)
17900 JX=-1
18000 JMPR=-1
18200 C KZ IS FOR "CLOSE IT"
18300 NZ=-1
18400 RX=X
18500 RY=Y
18600 5 CALL DPYOUT(1)
18650 L=J-1
18700 TYPE 46,L,SJ,SK
18800
18900 170 CALL SETCUR(NX,NY,JC)
19000 GO TO 4
19020 74 FORMAT(' S(TEP) OR L(IGHT PEN)? ',$)
19100 7 IF(K.NE.'E')GO TO 71
19200 C E=EDIT
19240 CC700 TYPE 74
19250 CC ACCEPT 1,K,X
19260 CC IF(K.NE.'L')GO TO 79
19300 CC IF(ZK.NE.0)JCX=ZK
19400 C SETS "ZEROING-IN" FIRST COUNTER
19500 CC NZ=0
19600
19605 CC KE=0
19610 C EDIT FLAG KE=0
19700 CC TYPE 70
19800 CC GO TO 44
19900 CC70 FORMAT(' CHOOSE A POINT ')
20600 71 IF(ZK.EQ.0)ZK=1
20700 IF(K.EQ.'L'.OR.K.EQ.'D')ZK=-ZK
20900 IF(K.EQ.'L'.OR.K.EQ.'R')GO TO 77
21000 SK=ZK+SK
21100 Y=GTPT(SK,CENTR)
21200 GO TO 78
21300 77 SJ=ZK+SJ
21400 X=GTPT(SJ,RJB)
21500 78 CALL BUP
21600 J=J-1
21800 GO TO 48
21900 79 S=-1
22000 JA=ZK-1
22100 84 IF(JA.LT.2)JA=1
22200 81 IF(K.NE.'D')JA=JA+1
22250 IF(JA.GT.J)JA=J
22300 X=SCLEF(JA,1)
22400 Y=SCLEF(JA,2)
22500 NX=X
22600 NY=Y
22700 NEXT=JA+1
22800 CALL SETCUR(NX,NY,0)
22900 GO TO 58
23000 82 IF(X.EQ.0)X=-1
23100 JA=JA-1+X
23200 GO TO 84
23300 22 IF(J.EQ.JZ)GO TO 4
23400 C CAN'T BACKUP PAST 1 OR 'F'
23500 J=J-1
23900 122 CALL UNPACK(J,IJ,IK,MCLEF)
24000 CALL BUP
24100 SJ=IJ
24200 SK=IK
24500 IF(K.EQ.'B')GO TO 50
24600 RJ=RJ+QJ
24700 RK=RK+QK
24800 GO TO 241
25000 3 MCLEF(1)=J
25100 IF(MCLEF(2).LT.100000000)MCLEF(2)=MCLEF(2)+100000000
25500 34 CALL CLRCUR
25700 IF(K.NE.'X')GO TO 120
27100 1 FORMAT(A1,2F)
27200 11 FORMAT(3F)
27300 46 FORMAT(I3,'.)',2F6.0/)
27500 END